home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGofer 0.22d / MacGofer Sources / cmachine.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-01-07  |  51.7 KB  |  1,947 lines  |  [TEXT/MPS ]
  1. /* --------------------------------------------------------------------------
  2.  * cmachine.c:  Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *        Gofer Compiler version 1.01 February 1992
  5.  *              Incorporated into mainstream Gofer 2.25, October 1992.
  6.  *              Gofer version 2.28 January 1993
  7.  *
  8.  * Compilation to simple G-code & (slightly) optimised translation to C code
  9.  * ------------------------------------------------------------------------*/
  10.  
  11. #include "prelude.h"
  12. #include "storage.h"
  13. #include "connect.h"
  14. #include "errors.h"
  15. #include <setjmp.h>
  16. #include <ctype.h>
  17.  
  18. #ifndef GOFC_INCLUDE
  19. #if     (TURBOC | BCC | DJGPP)
  20. #define GOFC_INCLUDE  "\"/gofer/gofc/gofc.h\""
  21. #else
  22. #if     MPW
  23. #define GOFC_INCLUDE "\"gofc.h\""
  24. #else
  25. #define GOFC_INCLUDE  "\"/usr/local/lib/Gofer/gofc.h\""
  26. #endif
  27. #endif
  28. #endif
  29.  
  30. /*#define DEBUG_CODE*/
  31.  
  32. Bool   andorOptimise = TRUE;        /* TRUE => optimise uses of &&, || */
  33.  
  34. #if DYNAMIC_STORAGE
  35. int num_addrs = NUM_ADDRS;
  36. #endif
  37.  
  38. /* --------------------------------------------------------------------------
  39.  * Data structures for machine memory (program storage):
  40.  * ------------------------------------------------------------------------*/
  41.  
  42. typedef enum {
  43.     iLOAD,   iCELL,   iCHAR,   iINT,   iFLOAT,
  44.     iSTRING, iMKAP,   iUPDATE, iUPDAP, iEVAL,
  45.     iRETURN, iINTGE,  iINTEQ,  iINTDV, iTEST,
  46.     iGOTO,   iSETSTK, iALLOC,  iSLIDE, iROOT,
  47.     iDICT,   iFLUSH,  iLABEL,  iSTKIS, iEND
  48. } Instr;
  49.  
  50. typedef Int Label;
  51.  
  52. typedef union {
  53.     Int   intVal;
  54. #if !BREAK_FLOATS
  55.       Float floatVal;
  56. #endif
  57.     Cell  cellVal;
  58.     Text  textVal;
  59.     Instr instrVal;
  60.     Label labVal;
  61. } MemCell;
  62.  
  63. typedef MemCell far *Memory;
  64. static    Memory        memory;
  65. #define intAt(m)    memory[m].intVal
  66. #if !BREAK_FLOATS
  67. #define floatAt(m)  memory[m].floatVal
  68. #endif
  69. #define cellAt(m)   memory[m].cellVal
  70. #define textAt(m)   memory[m].textVal
  71. #define instrAt(m)  memory[m].instrVal
  72. #define labAt(m)    memory[m].labVal
  73.  
  74. /* --------------------------------------------------------------------------
  75.  * Local function prototypes:
  76.  * ------------------------------------------------------------------------*/
  77.  
  78. static Void   local instrNone     Args((Instr));
  79. static Void   local instrInt     Args((Instr,Int));
  80. static Void   local instrFloat   Args((Instr,FloatPro));
  81. static Void   local instrCell     Args((Instr,Cell));
  82. static Void   local instrText     Args((Instr,Text));
  83. static Void   local instrLab     Args((Instr,Label));
  84. static Void   local instrIntLab     Args((Instr,Int,Label));
  85. static Void   local instrCellLab Args((Instr,Cell,Label));
  86.  
  87. static Void   local asSTART     Args((Void));
  88. static Label  local newLabel     Args((Void));
  89. static Void   local asLABEL     Args((Label));
  90. static Void   local asEND     Args((Void));
  91.  
  92. static Void   local asMKAP     Args((Int));
  93. static Void   local asUPDATE     Args((Int));
  94.  
  95. #ifdef DEBUG_CODE
  96. static Void   local dissassemble Args((Addr));
  97. static Void   local printCell     Args((Cell));
  98. static Addr   local dissNone     Args((Addr,String));
  99. static Addr   local dissInt     Args((Addr,String));
  100. static Addr   local dissFloat    Args((Addr,String));
  101. static Addr   local dissCell     Args((Addr,String));
  102. static Addr   local dissText     Args((Addr,String));
  103. static Addr   local dissLab     Args((Addr,String));
  104. static Addr   local dissIntLab     Args((Addr,String));
  105. static Addr   local dissCellLab     Args((Addr,String));
  106. #endif
  107.  
  108. static Void   local doCont     Args((Pair));
  109. static Pair   local flush     Args((Pair));
  110. static Void   local make     Args((Cell,Int,Label,Pair));
  111. static Void   local makeCond     Args((Cell,Cell,Cell,Int,Label,Pair));
  112. static Void   local makeCase     Args((Cell,Int,Label,Pair));
  113. static Void   local testCase     Args((Pair,Int,Label,Label,Pair));
  114. static Void   local makeGded     Args((List,Int,Label,Pair));
  115. static Bool   local testGuard     Args((Pair,Int,Label,Label,Pair));
  116.  
  117. static Void   local dependsOn     Args((Cell));
  118. static Void   local build     Args((Cell,Int));
  119. static Void   local buildGuards     Args((List,Int));
  120. static Int    local buildLoc     Args((List,Int));
  121.  
  122. static Void   local analyseAp     Args((Cell));
  123. static Void   local buildAp     Args((Cell,Int,Label,Bool));
  124.  
  125. static List   local identifyDeps Args((Name));
  126. static Void   local checkPrimDep Args((Name,Name));
  127. static Void   local outputCDecls Args((FILE *,List));
  128. static Void   local outputCDicts Args((FILE *));
  129.  
  130. static Void   local rspRecalc     Args((Void));
  131.  
  132. static Void   local outputCSc     Args((FILE *,Name));
  133. static List   local cCode     Args((Int,Addr));
  134. static List   local heapUse     Args((List));
  135. static List   local heapAnalyse     Args((List));
  136. static Void   local outputCinst     Args((FILE *,Cell));
  137.  
  138. static Void   local expr     Args((FILE *,Cell));
  139. static Void   local outputLabel  Args((FILE *,Int));
  140. static Void   local outputJump     Args((FILE *,Int));
  141. static Void   local outputCStr     Args((FILE *, String));
  142. static Bool   local validCstring Args((String));
  143. static String local scNameOf     Args((Name));
  144.  
  145. static Void   local startTable     Args((String,String,String));
  146. static Void   local tableItem     Args((FILE *,String));
  147. static Void   local finishTable     Args((FILE *));
  148.  
  149. /* --------------------------------------------------------------------------
  150.  * Assembler: (Low level, instruction code storage)
  151.  * ------------------------------------------------------------------------*/
  152.  
  153. static Addr  startInstr;        /* first instruction after START   */
  154. static Addr  lastInstr;            /* last instr written (for peephole*/
  155.                     /* optimisations etc.)           */
  156. static Int   srsp;            /* simulated runtime stack pointer */
  157. #if DYNAMIC_STORAGE
  158.        Int  *offsPosn;
  159. #else
  160. static Int   offsPosn[NUM_OFFSETS];    /* mapping from logical to physical*/
  161.                     /* offset positions           */
  162. #endif
  163.  
  164. static Void local instrNone(opc)    /* Opcode with no operands       */
  165. Instr opc; {
  166.     lastInstr           = getMem(1);
  167.     instrAt(lastInstr) = opc;
  168. }
  169.  
  170. static Void local instrInt(opc,n)    /* Opcode with integer operand       */
  171. Instr opc;
  172. Int   n; {
  173.     lastInstr           = getMem(2);
  174.     instrAt(lastInstr) = opc;
  175.     intAt(lastInstr+1) = n;
  176. }
  177.  
  178. static Void local instrFloat(opc,fl)    /* Opcode with Float operand       */
  179. Instr opc;
  180. FloatPro fl; {
  181. #if BREAK_FLOATS
  182.     lastInstr         = getMem(3);
  183.     instrAt(lastInstr)     = opc;
  184.     cellAt(lastInstr+1)     = part1Float(fl);
  185.     cellAt(lastInstr+2)     = part2Float(fl);
  186. #else
  187.     lastInstr            = getMem(2);
  188.     instrAt(lastInstr)   = opc;
  189.     floatAt(lastInstr+1) = fl;
  190. #endif
  191. }
  192.  
  193. static Void local instrCell(opc,c)    /* Opcode with Cell operand       */
  194. Instr opc;
  195. Cell  c; {
  196.     lastInstr        = getMem(2);
  197.     instrAt(lastInstr)    = opc;
  198.     cellAt(lastInstr+1) = c;
  199. }
  200.  
  201. static Void local instrText(opc,t)    /* Opcode with Text operand       */
  202. Instr opc;
  203. Text  t; {
  204.     lastInstr        = getMem(2);
  205.     instrAt(lastInstr)    = opc;
  206.     textAt(lastInstr+1) = t;
  207. }
  208.  
  209. static Void local instrLab(opc,l)    /* Opcode with label operand       */
  210. Instr opc;
  211. Label l; {
  212.     lastInstr           = getMem(2);
  213.     instrAt(lastInstr) = opc;
  214.     labAt(lastInstr+1) = l;
  215.     if (l<0)
  216.     internal("bad Label");
  217. }
  218.  
  219. static Void local instrIntLab(opc,n,l)    /* Opcode with int, label operands */
  220. Instr opc;
  221. Int   n;
  222. Label l; {
  223.     lastInstr           = getMem(3);
  224.     instrAt(lastInstr) = opc;
  225.     intAt(lastInstr+1) = n;
  226.     labAt(lastInstr+2) = l;
  227.     if (l<0)
  228.     internal("bad Label");
  229. }
  230.  
  231. static Void local instrCellLab(opc,c,l)    /* Opcode with cell, label operands*/
  232. Instr opc;
  233. Cell  c;
  234. Label l; {
  235.     lastInstr        = getMem(3);
  236.     instrAt(lastInstr)    = opc;
  237.     cellAt(lastInstr+1) = c;
  238.     labAt(lastInstr+2)    = l;
  239.     if (l<0)
  240.     internal("bad Label");
  241. }
  242.  
  243. /* --------------------------------------------------------------------------
  244.  * Main low level assembler control: (includes label assignment and fixup)
  245.  * ------------------------------------------------------------------------*/
  246.  
  247. static    Label        nextLab;        /* next label number to allocate   */
  248. #if DYNAMIC_STORAGE
  249.         Label       *fixups;
  250. #else
  251. static  Label       fixups[NUM_FIXUPS]; /* fixups for label values       */
  252. #endif
  253. #define FAIL        0            /* special label for fail()       */
  254.  
  255. #define fix(a)      labAt(a) = fixups[labAt(a)]
  256.  
  257. static Void local asSTART() {        /* initialise assembler           */
  258.     fixups[0]    = FAIL;            /* use label 0 for fail()       */
  259.     nextLab    = 1;
  260.     startInstr    = getMem(0);
  261.     lastInstr    = startInstr-1;
  262.     srsp    = 0;
  263.     offsPosn[0]    = 0;
  264. }
  265.  
  266. static Label local newLabel() {        /* allocate new label           */
  267.     if (nextLab>=NUM_FIXUPS) {
  268.     ERROR(0) "Compiled code too complex"
  269.     EEND;
  270.     }
  271.     return nextLab++;
  272. }
  273.  
  274. static Void local asLABEL(l)        /* indicate label reached       */
  275. Label l; {
  276.     if (instrAt(lastInstr)==iGOTO && labAt(lastInstr+1)==l) {
  277.     instrAt(lastInstr) = iLABEL;    /* GOTO l; LABEL l  ==>  LABEL l   */
  278.     fixups[l] = l;
  279.     }
  280.     else if (instrAt(lastInstr)==iLABEL)/* code already labelled at this pt*/
  281.     fixups[l] = labAt(lastInstr+1);    /* so use previous label       */
  282.     else {
  283.     instrLab(iLABEL,l);        /* otherwise insert new label       */
  284.     fixups[l] = l;
  285.     }
  286. }
  287.  
  288. static Void local asEND() {        /* Fix addresses in assembled code */
  289.     Addr pc = startInstr;
  290.  
  291.     instrNone(iEND);            /* insert END opcode           */
  292.     for (;;)
  293.     switch (instrAt(pc)) {
  294.         case iEND     : return;    /* end of code sequence           */
  295.  
  296.         case iEVAL     :        /* opcodes taking no arguments       */
  297.         case iFLUSH  :
  298.         case iRETURN : pc++;
  299.                break;
  300.  
  301.         case iGOTO     : fix(pc+1);    /* opcodes taking one argument       */
  302.         case iLABEL     : /* no need for a fix here !*/
  303.         case iSETSTK :
  304.         case iSTKIS :
  305.         case iALLOC  :
  306.         case iSLIDE  :
  307.         case iROOT     :
  308.             case iDICT   :
  309.         case iLOAD     :
  310.         case iCELL     :
  311.         case iCHAR     :
  312.         case iINT     :
  313. #if !BREAK_FLOATS
  314.           case iFLOAT  :
  315. #endif
  316.         case iSTRING :
  317.         case iMKAP     :
  318.         case iUPDATE :
  319.         case iUPDAP  : pc+=2;
  320.                break;
  321.  
  322. #if BREAK_FLOATS
  323.         case iFLOAT  : pc+=3;
  324.                break;
  325. #endif
  326.         case iINTGE  :        /* opcodes taking two arguments       */
  327.         case iINTEQ  :
  328.         case iINTDV     :
  329.         case iTEST     : fix(pc+2);
  330.                pc+=3;
  331.                break;
  332.  
  333.         default     : internal("asEND");
  334.     }
  335. }
  336.  
  337. /* --------------------------------------------------------------------------
  338.  * Assembler Opcodes: (includes simple peephole optimisations)
  339.  * ------------------------------------------------------------------------*/
  340.  
  341. #define asINTEGER(n) instrInt(iINT,n);        srsp++
  342. #define asFLOAT(fl)  instrFloat(iFLOAT,fl);    srsp++
  343. #define asCHAR(n)    instrInt(iCHAR,n);        srsp++
  344. #define asLOAD(n)    instrInt(iLOAD,n);        srsp++
  345. #define asALLOC(n)   instrInt(iALLOC,n);    srsp+=n
  346. #define asROOT(n)    instrInt(iROOT,n);        srsp++
  347. #define asSETSTK(n)  instrInt(iSETSTK,n);    srsp=n
  348. #define asSTKIS(n)   instrInt(iSTKIS,n);    srsp=n
  349. #define asEVAL()     instrNone(iEVAL);        srsp--  /* inaccurate srsp */
  350. #define asFLUSH()    instrNone(iFLUSH)
  351. #define asRETURN()   instrNone(iRETURN)
  352. #define asCELL(c)    instrCell(iCELL,c);    srsp++
  353. #define asTEST(c,l)  instrCellLab(iTEST,c,l)        /* inaccurate srsp */
  354. #define asINTGE(n,l) instrIntLab(iINTGE,n,l)        /* inaccurate srsp */
  355. #define asINTEQ(n,l) instrIntLab(iINTEQ,n,l)
  356. #define asINTDV(n,l) instrIntLab(iINTDV,n,l)        /* inaccurate srsp */
  357. #define asGOTO(l)    instrLab(iGOTO,l)
  358. #define asSLIDE(n)   instrInt(iSLIDE,n);    srsp-=n
  359. #define asDICT(n)    if (n>0) instrInt(iDICT,n)
  360. #define asSTRING(t)  if (*textToStr(t))            \
  361.              instrText(iSTRING,t);        \
  362.              else                \
  363.              instrCell(iCELL,nameNil);    \
  364.              srsp++
  365.  
  366. static Void local asMKAP(n)        /* Make application nodes ...       */
  367. Int n; {
  368.     if (instrAt(lastInstr)==iMKAP)    /* Peephole optimisation:       */
  369.     intAt(lastInstr+1)+=n;        /* MKAP n; MKAP m  ===> MKAP (n+m) */
  370.     else
  371.     instrInt(iMKAP,n);
  372.     srsp -= n;
  373. }
  374.  
  375. static Void local asUPDATE(n)        /* Update node ...           */
  376. Int n; {
  377.     if (instrAt(lastInstr)==iMKAP) {    /* Peephole optimisations:       */
  378.     if (intAt(lastInstr+1)>1) {    /* MKAP (n+1); UPDATE p           */
  379.         intAt(lastInstr+1)--;    /*          ===> MKAP n; UPDAP p */
  380.         instrInt(iUPDAP,n);
  381.     }
  382.     else {
  383.         instrAt(lastInstr) = iUPDAP;
  384.         intAt(lastInstr+1) = n;    /* MKAP 1; UPDATE p ===> UPDAP p   */
  385.     }
  386.     }
  387.     else
  388.     instrInt(iUPDATE,n);
  389.     srsp--;
  390. }
  391.  
  392. /* --------------------------------------------------------------------------
  393.  * Dissassembler:
  394.  * ------------------------------------------------------------------------*/
  395.  
  396. #ifdef DEBUG_CODE
  397. static Void local dissassemble(pc)    /* print dissassembly of code       */
  398. Addr pc; {
  399.     for (;;)
  400.     switch (instrAt(pc)) {
  401.         case iEND     : return;
  402.         case iLOAD     : pc = dissInt(pc,"LOAD");     break;
  403.         case iCELL     : pc = dissCell(pc,"CELL");     break;
  404.         case iCHAR     : pc = dissInt(pc,"CHAR");     break;
  405.         case iINT     : pc = dissInt(pc,"INT");     break;
  406.         case iFLOAT  : pc = dissFloat(pc,"FLOAT");   break;
  407.         case iSTRING : pc = dissText(pc,"STRING");     break;
  408.         case iMKAP     : pc = dissInt(pc,"MKAP");     break;
  409.         case iUPDATE : pc = dissInt(pc,"UPDATE");     break;
  410.         case iUPDAP  : pc = dissInt(pc,"UPDAP");     break;
  411.         case iEVAL     : pc = dissNone(pc,"EVAL");     break;
  412.         case iFLUSH  : pc = dissNone(pc,"FLUSH");     break;
  413.         case iRETURN : pc = dissNone(pc,"RETURN");     break;
  414.         case iSETSTK : pc = dissInt(pc,"SETSTK");     break;
  415.         case iSTKIS  : pc = dissInt(pc,"STKIS");     break;
  416.         case iALLOC  : pc = dissInt(pc,"ALLOC");     break;
  417.         case iSLIDE  : pc = dissInt(pc,"SLIDE");     break;
  418.         case iROOT     : pc = dissInt(pc,"ROOT");     break;
  419.             case iDICT   : pc = dissInt(pc,"DICT");      break;
  420.         case iINTGE  : pc = dissIntLab(pc,"INTGE");     break;
  421.         case iINTEQ  : pc = dissIntLab(pc,"INTEQ");     break;
  422.         case iINTDV  : pc = dissIntLab(pc,"INTDV");     break;
  423.         case iTEST     : pc = dissCellLab(pc,"TEST");     break;
  424.         case iGOTO     : pc = dissLab(pc,"GOTO");     break;
  425.         case iLABEL  : pc = dissLab(pc,"LABEL");     break;
  426.         default     : internal("unknown instruction");
  427.     }
  428. }
  429.  
  430. static Void local printCell(c)           /* printable representation of Cell */
  431. Cell c; {
  432.     if (isName(c))
  433.     printf("%s",textToStr(name(c).text));
  434.     else
  435.     printf("$%d",c);
  436. }
  437.  
  438. static Addr local dissNone(pc,s)       /* dissassemble instr no args       */
  439. Addr   pc;
  440. String s; {
  441.     printf("%s\n",s);
  442.     return pc+1;
  443. }
  444.  
  445. static Addr local dissInt(pc,s)        /* dissassemble instr with Int arg  */
  446. Addr   pc;
  447. String s; {
  448.     printf("%s\t%d\n",s,intAt(pc+1));
  449.     return pc+2;
  450. }
  451.  
  452. static Addr local dissFloat(pc,s)      /* dissassemble instr with Float arg*/
  453. Addr   pc;
  454. String s; {
  455. #if BREAK_FLOATS
  456.     printf("%s\t%s\n",s,
  457.     floatToString(floatFromParts(cellAt(pc+1),cellAt(pc+2))));
  458.     return pc+3;
  459. #else
  460.     printf("%s\t%s\n",s,floatToString(floatAt(pc+1)));
  461.     return pc+2;
  462. #endif
  463. }
  464.  
  465. static Addr local dissCell(pc,s)       /* dissassemble instr with Cell arg */
  466. Addr   pc;
  467. String s; {
  468.     printf("%s\t",s);
  469.     printCell(cellAt(pc+1));
  470.     printf("\n");
  471.     return pc+2;
  472. }
  473.  
  474. static Addr local dissText(pc,s)       /* dissassemble instr with Text arg */
  475. Addr   pc;
  476. String s; {
  477.     printf("%s\t%s\n",s,textToStr(textAt(pc+1)));
  478.     return pc+2;
  479. }
  480.  
  481. static Addr local dissLab(pc,s)       /* dissassemble instr with Label arg */
  482. Addr   pc;
  483. String s; {
  484.     printf("%s\t%d\n",s,labAt(pc+1));
  485.     return pc+2;
  486. }
  487.  
  488. static Addr local dissIntLab(pc,s)    /* dissassemble instr with Int+Label */
  489. Addr   pc;
  490. String s; {
  491.     printf("%s\t%d\t%d\n",s,intAt(pc+1),labAt(pc+2));
  492.     return pc+3;
  493. }
  494.  
  495. static Addr local dissCellLab(pc,s)   /* dissassemble instr with Cell+Label*/
  496. Addr   pc;
  497. String s; {
  498.     printf("%s\t",s);
  499.     printCell(cellAt(pc+1));
  500.     printf("\t%d\n",labAt(pc+2));
  501.     return pc+3;
  502. }
  503. #endif
  504.  
  505. /* --------------------------------------------------------------------------
  506.  * Compile expression to code which will build expression evaluating guards
  507.  * and testing cases to avoid building complete graph.
  508.  *
  509.  * This section of code has been rewritten from the original form in
  510.  * version 2.21 of the interpreter to use a more sophisticated form of
  511.  * continuation rather than the simple UPDRET/SHOULDNTFAIL/label etc
  512.  * used in that program.  The aim of this rewrite is (of course) to try
  513.  * and produce better output code.  The basic type for continuations is:
  514.  *
  515.  *    type Continuation = (Int, ThenWhat)
  516.  *    data ThenWhat      = RUNONC         -- next instr
  517.  *              | FRUNONC        -- FLUSH then next instr
  518.  *              | BRANCH Label    -- branch to label
  519.  *              | FBRANCH Label    -- FLUSH then branch
  520.  *              | UPDRETC        -- UPDATE 0; RETURN
  521.  *
  522.  * As an example of the kind of optimisations we can get by this:
  523.  *
  524.  *  ...; MKAP 4; SLIDE m ; UPDATE 0 ; RETURN
  525.  *                     ====> ...; MKAP 3; UPDAP 0; RETURN
  526.  *
  527.  *  ...; MKAP 2; FLUSH ; UPDATE 0; RETURN
  528.  *                     ====> ...; MKAP 1; UPDAP 0; RETURN
  529.  *
  530.  *  ...; SLIDE m; SLIDE n; ...       ====> ...; SLIDE (m+n); ...
  531.  *  (this one was previously obtained by a peephole optimisation)
  532.  * ------------------------------------------------------------------------*/
  533.  
  534. static Pair shouldntFail;        /* error continuation           */
  535. static Pair functionReturn;        /* initial function continuation   */
  536. static Pair noAction;            /* skip continuation           */
  537.  
  538. static Void local doCont(c)        /* insert code for continuation    */
  539. Pair c; {
  540.     Int sl = intOf(fst(c));
  541.     switch (whatIs(snd(c))) {
  542.     case FRUNONC : asFLUSH();
  543.     case RUNONC  : if (sl>0) {
  544.                asSLIDE(sl);
  545.                }
  546.                break;
  547.  
  548.     case FBRANCH : asFLUSH();
  549.     case BRANCH  : if (sl>0) {
  550.                asSLIDE(sl);
  551.                }
  552.                asGOTO(intOf(snd(snd(c))));
  553.                break;
  554.  
  555.     case UPDRETC : asUPDATE(0);
  556.                asRETURN();
  557.                        break;
  558.  
  559.     case ERRCONT :
  560.     default         : internal("doCont");
  561.     }
  562. }
  563.  
  564. #define slide(n,d)   pair(mkInt(intOf(fst(d))+n),snd(d))
  565. #define isRunon(d)   (snd(d)==RUNONC || snd(d)==FRUNONC)
  566. #define fbranch(l,d) pair(fst(d),ap(FBRANCH,l))
  567. #define frunon(d)    pair(fst(d),FRUNONC)
  568.  
  569. static Pair local flush(d)        /* force flush on continuation       */
  570. Pair d; {
  571.     switch (whatIs(snd(d))) {
  572.     case RUNONC : return frunon(d);
  573.     case BRANCH : return fbranch(snd(snd(d)),d);
  574.     default        : return d;
  575.     }
  576. }
  577.  
  578. static Void local make(e,co,f,d)    /* Construct code to build e, given*/
  579. Cell  e;                /* current offset co, and branch   */
  580. Int   co;                /* to f on failure, d on completion*/
  581. Label f;
  582. Pair  d; {
  583.     switch (whatIs(e)) {
  584.  
  585.     case LETREC    : {   Int n = buildLoc(fst(snd(e)),co);
  586.                  make(snd(snd(e)),co+n,f,slide(n,d));
  587.                  }
  588.                  break;
  589.  
  590.     case FATBAR    : if (isRunon(d)) {
  591.                  Label l1     = newLabel();
  592.                  Label l2     = newLabel();
  593.                  Int   savesp = srsp;
  594.                  make(fst(snd(e)),co,l1,fbranch(mkInt(l2),d));
  595.                  asLABEL(l1);
  596.                   asSETSTK(savesp);
  597.                  make(snd(snd(e)),co,f,frunon(d));
  598.                  asLABEL(l2);
  599.              }
  600.              else {
  601.                  Label l  = newLabel();
  602.                  Cell  d1 = flush(d);
  603.                  Int   savesp = srsp;
  604.                  make(fst(snd(e)),co,l,d1);
  605.                  asLABEL(l);
  606.                  asSETSTK(savesp);
  607.                  make(snd(snd(e)),co,f,d1);
  608.              }
  609.                          break;
  610.  
  611.     case COND      : makeCond(fst3(snd(e)),
  612.                   snd3(snd(e)),
  613.                   thd3(snd(e)),co,f,d);
  614.                  break;
  615.  
  616.     case CASE      : makeCase(snd(e),co,f,d);
  617.              break;
  618.  
  619.     case GUARDED   : makeGded(snd(e),co,f,d);
  620.                  break;
  621.  
  622.     case AP        : if (andorOptimise) {
  623.                  Cell h = getHead(e);
  624.                  if (h==nameAnd && argCount==2) {
  625.                  /* x && y ==> if x then y else False       */
  626.                  makeCond(arg(fun(e)),arg(e),nameFalse,co,f,d);
  627.                  break;
  628.                  }
  629.                  else if (h==nameOr && argCount==2) {
  630.                  /* x || y ==> if x then True else y       */
  631.                  makeCond(arg(fun(e)),nameTrue,arg(e),co,f,d);
  632.                  break;
  633.                  }
  634.              }
  635.                          buildAp(e,co,f,TRUE);
  636.                          doCont(d);
  637.                          break;
  638.  
  639.     case NAME      : dependsOn(e);
  640.     case UNIT      :
  641.     case TUPLE     : asCELL(e);
  642.                  doCont(d);
  643.                  break;
  644.  
  645.     /* for dict cells, ensure that CELL referred to in the code is the */
  646.     /* dictionary cell at the head of the dictionary; not just a copy  */
  647.     /* In the interpreter, this was needed for the benefit of garbage  */
  648.     /* collection (and to avoid having multiple copies of a single       */
  649.     /* DICTCELL).  In the compiler, we need it to justify the use of   */
  650.     /* cellIsMember() in dependsOn() below.                   */
  651.  
  652.     case DICTCELL  : asCELL(dict(dictOf(e)));
  653.              dependsOn(dict(dictOf(e)));
  654.                  doCont(d);
  655.                  break;
  656.  
  657.     case INTCELL   : asINTEGER(intOf(e));
  658.                  doCont(d);
  659.                  break;
  660.  
  661.         case FLOATCELL : asFLOAT(floatOf(e));
  662.                  doCont(d);
  663.              break;
  664.  
  665.     case STRCELL   : asSTRING(textOf(e));
  666.                  doCont(d);
  667.                  break;
  668.  
  669.     case CHARCELL  : asCHAR(charOf(e));
  670.                  doCont(d);
  671.                  break;
  672.  
  673.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  674.                  doCont(d);
  675.                  break;
  676.  
  677.     default        : internal("make");
  678.     }
  679. }
  680.  
  681. static Void local makeCond(i,t,e,co,f,d)/* Build code for conditional       */
  682. Cell  i,t,e;
  683. Int   co;
  684. Label f;
  685. Pair  d; {
  686.     if (andorOptimise && i==nameOtherwise)
  687.     make(t,co,f,d);
  688.     else {
  689.     Label l1 = newLabel();
  690.     Int   savesp;
  691.  
  692.     make(i,co,f,noAction);
  693.     asEVAL();
  694.     savesp = srsp;
  695.     asTEST(nameTrue,l1);
  696.     if (isRunon(d)) {
  697.         Label l2 = newLabel();
  698.  
  699.         make(t,co,f,fbranch(mkInt(l2),d));
  700.             asLABEL(l1);
  701.          if (srsp!=savesp)
  702.          asSETSTK(savesp);
  703.         make(e,co,f,frunon(d));
  704.         asLABEL(l2);
  705.     }
  706.     else {
  707.         Cell d1 = flush(d);
  708.         make(t,co,f,d1);
  709.         asLABEL(l1);
  710.         if (srsp!=savesp)
  711.         asSETSTK(savesp);
  712.         make(e,co,f,d1);
  713.     }
  714.     }
  715. }
  716.  
  717. static Void local makeCase(c,co,f,d)    /* construct code to implement case*/
  718. Cell  c;                /* makes the assumption that FLUSH */
  719. Int   co;                /* will never be required       */
  720. Label f;
  721. Pair  d; {
  722.     List  cs = snd(c);
  723.     Cell  d1 = d;
  724.     Label l0;
  725.  
  726.     make(fst(c),co,shouldntFail,noAction);
  727.     asEVAL();
  728.  
  729.     if (isRunon(d)) {
  730.     l0 = newLabel();
  731.     d1 = pair(mkInt(0),ap(BRANCH,mkInt(l0)));
  732.     }
  733.  
  734.     for(; nonNull(tl(cs)); cs=tl(cs)) {
  735.     Label l      = newLabel();
  736.         Int   savesp = srsp;
  737.     testCase(hd(cs),co,f,l,d1);
  738.     asLABEL(l);
  739.     asSTKIS(srsp);
  740.      }
  741.  
  742.     if (isRunon(d)) {
  743.         Int savesp = srsp;
  744.     testCase(hd(cs),co,f,f,noAction);
  745.     asLABEL(l0);
  746.         srsp = savesp;
  747.     }
  748.     else
  749.     testCase(hd(cs),co,f,f,d1);
  750. }
  751.  
  752. static Void local testCase(c,co,f,cf,d)    /* Produce code for guard       */
  753. Pair  c;
  754. Int   co;                /* labels determine where to go if:*/
  755. Label f;                /* match succeeds, but rest fails  */
  756. Label cf;                /* this match fails           */
  757. Pair  d; {
  758.     Int n = discrArity(fst(c));
  759.     Int i;
  760.     switch (whatIs(fst(c))) {
  761.     case INTCELL : asINTEQ(intOf(fst(c)),cf);
  762.                break;
  763.     case ADDPAT  : asINTGE(intValOf(fst(c)),cf);
  764.                break;
  765.     case MULPAT  : asINTDV(intValOf(fst(c)),cf);
  766.                break;
  767.     default      : asTEST(fst(c),cf);
  768.                break;
  769.     }
  770.     for (i=1; i<=n; i++)
  771.     offsPosn[co+i] = ++srsp;
  772.     make(snd(c),co+n,f,d);
  773. }
  774.  
  775. static Void local makeGded(gs,co,f,d)    /* construct code to implement gded*/
  776. List  gs;                /* equations.  Makes the assumption*/
  777. Int   co;                /* that FLUSH will never be reqd.  */
  778. Label f;
  779. Pair  d; {
  780.     Cell  d1 = d;
  781.     Label l0;
  782.  
  783.     if (isRunon(d)) {
  784.     l0 = newLabel();
  785.     d1 = pair(mkInt(0),ap(BRANCH,mkInt(l0)));
  786.     }
  787.  
  788.     for(; nonNull(tl(gs)); gs=tl(gs)) {
  789.     Label l = newLabel();
  790.         Int   savesp = srsp;
  791.     if (testGuard(hd(gs),co,f,l,d1))
  792.         return;
  793.     asLABEL(l);
  794.     asSTKIS(srsp);
  795.     }
  796.  
  797.     if (isRunon(d)) {
  798.         Int   savesp = srsp;
  799.     testGuard(hd(gs),co,f,f,noAction);
  800.     asLABEL(l0);
  801.     asSTKIS(srsp);
  802.     }
  803.     else
  804.     testGuard(hd(gs),co,f,f,d1);
  805. }
  806.  
  807. static Bool local testGuard(g,co,f,cf,d) /* Produce code for guard       */
  808. Pair  g;                /* return TRUE if otherwise found  */
  809. Int   co;
  810. Label f;
  811. Label cf;
  812. Pair  d; {
  813.     if (andorOptimise && fst(g)==nameOtherwise) {
  814.     make(snd(g),co,f,d);
  815.     return TRUE;
  816.     }
  817.     else {
  818.     make(fst(g),co,shouldntFail,noAction);
  819.     asEVAL();
  820.     asTEST(nameTrue,cf);
  821.     make(snd(g),co,f,d);
  822.     return FALSE;
  823.     }
  824. }
  825.  
  826. /* --------------------------------------------------------------------------
  827.  * Compile expression to code which will build expression without any
  828.  * evaluation.
  829.  * ------------------------------------------------------------------------*/
  830.  
  831. static List scDeps;            /* records immediate dependent       */
  832.                     /* names and dictionaries       */
  833.  
  834. static Void local dependsOn(n)        /* update scDeps with new name       */
  835. Cell n; {
  836.  
  837.     if (isName(n))            /* ignore:               */
  838.     if (name(n).defn == CFUN ||    /* - constructor functions       */
  839.         name(n).defn == MFUN)    /* - member fns (shouldn't occur)  */
  840.         return;
  841.  
  842.     if (!cellIsMember(n,scDeps))    /* add to list of dependents       */
  843.     scDeps = cons(n,scDeps);
  844. }
  845.  
  846. static Void local build(e,co)        /* Generate code which will build  */
  847. Cell e;                 /* instance of given expression but*/
  848. Int  co; {                /* perform no evaluation        */
  849.     Int n;
  850.  
  851.     switch (whatIs(e)) {
  852.  
  853.     case LETREC    : n = buildLoc(fst(snd(e)),co);
  854.                  build(snd(snd(e)),co+n);
  855.                  asSLIDE(n);
  856.                  break;
  857.  
  858.     case FATBAR    : build(snd(snd(e)),co);
  859.                  build(fst(snd(e)),co);
  860.                  asCELL(nameFatbar);
  861.                  asMKAP(2);
  862.                  break;
  863.  
  864.     case COND      : build(thd3(snd(e)),co);
  865.                  build(snd3(snd(e)),co);
  866.                  build(fst3(snd(e)),co);
  867.                  asCELL(nameIf);
  868.                    asMKAP(3);
  869.                    break;
  870.  
  871.     case GUARDED   : buildGuards(snd(e),co);
  872.                  break;
  873.  
  874.     case AP        : buildAp(e,co,shouldntFail,FALSE);
  875.                  break;
  876.  
  877.     case NAME      : dependsOn(e);
  878.     case UNIT      :
  879.     case TUPLE     : asCELL(e);
  880.              break;
  881.  
  882.     case DICTCELL  : asCELL(dict(dictOf(e)));    /* see comments for*/
  883.              dependsOn(dict(dictOf(e)));    /* DICTCELL in make*/
  884.              break;                /* function above  */
  885.  
  886.     case INTCELL   : asINTEGER(intOf(e));
  887.              break;
  888.  
  889.         case FLOATCELL : asFLOAT(floatOf(e));
  890.              break;
  891.  
  892.     case STRCELL   : asSTRING(textOf(e));
  893.              break;
  894.  
  895.     case CHARCELL  : asCHAR(charOf(e));
  896.              break;
  897.  
  898.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  899.                  break;
  900.  
  901.     default        : internal("build");
  902.     }
  903. }
  904.  
  905. static Void local buildGuards(gs,co)    /* Generate code to compile list   */
  906. List gs;                /* of guards to a conditional expr */
  907. Int  co; {                /* without evaluation           */
  908.     if (isNull(gs)) {
  909.     asCELL(nameFail);
  910.     }
  911.     else {
  912.     buildGuards(tl(gs),co);
  913.     build(snd(hd(gs)),co);
  914.     build(fst(hd(gs)),co);
  915.     asCELL(nameIf);
  916.     asMKAP(3);
  917.     }
  918. }
  919.  
  920. static Int local buildLoc(vs,co)    /* Generate code to build local var*/
  921. List vs;                /* bindings on stack,  with no eval*/
  922. Int  co; {
  923.     Int n = length(vs);
  924.     Int i;
  925.  
  926.     for (i=1; i<=n; i++)
  927.     offsPosn[co+i] = srsp+i;
  928.     asALLOC(n);
  929.     for (i=1; i<=n; i++) {
  930.     build(hd(vs),co+n);
  931.     asUPDATE(offsPosn[co+i]);
  932.     vs = tl(vs);
  933.     }
  934.     return n;
  935. }
  936.  
  937. /* --------------------------------------------------------------------------
  938.  * We frequently encounter functions which call themselves recursively with
  939.  * a number of initial arguments preserved:
  940.  * e.g.  (map f) []    = []
  941.  *     (map f) (x:xs) = f x : (map f) xs
  942.  * Lambda lifting, in particular, is likely to introduce such functions.
  943.  * Rather than reconstructing a new instance of the recursive function and
  944.  * it's arguments, we can extract the relevant portion of the root of the
  945.  * current redex.
  946.  *
  947.  * The following functions implement this optimisation.
  948.  * ------------------------------------------------------------------------*/
  949.  
  950. static Int  nonRoots;               /* #args which can't get from root  */
  951. static Int  rootPortion;           /* portion of root used ...       */
  952. static Name definingName;           /* name of func being defined,if any*/
  953. static Int  definingArity;           /* arity of definingName        */
  954.  
  955. static Void local analyseAp(e)           /* Determine if any portion of an   */
  956. Cell e; {                   /* application can be built using a */
  957.     if (isAp(e)) {               /* portion of the root           */
  958.     analyseAp(fun(e));
  959.     if (nonRoots==0 && rootPortion>1
  960.             && isOffset(arg(e))
  961.             && offsetOf(arg(e))==rootPortion-1)
  962.         rootPortion--;
  963.     else
  964.         nonRoots++;
  965.     }
  966.     else if (e==definingName)
  967.     rootPortion = definingArity+1;
  968.     else
  969.     rootPortion = 0;
  970. }
  971.  
  972. static Void local buildAp(e,co,f,str)    /* Build application, making use of*/
  973. Cell  e;                /* root optimisation if poss.       */
  974. Int   co;
  975. Label f;
  976. Bool  str; {
  977.     Int nr, rp, i;
  978.  
  979.     nonRoots = 0;
  980.     analyseAp(e);
  981.     nr = nonRoots;
  982.     rp = rootPortion;
  983.  
  984.     for (i=0; i<nr; ++i) {
  985.     build(arg(e),co);
  986.     e = fun(e);
  987.     }
  988.  
  989.     if (isSelect(e)) {
  990.         if (selectOf(e)>0) {
  991.         asDICT(selectOf(e));
  992.     }
  993.     }
  994.     else {
  995.     if (isName(e) && name(e).defn==MFUN) {
  996.         asDICT(name(e).number);
  997.         nr--;    /* AP node for member function need never be built */
  998.     }
  999.     else {
  1000.         if (0<rp && rp<=definingArity) {
  1001.         asROOT(rp-1);
  1002.         }
  1003.         else
  1004.         if (str)
  1005.             make(e,co,f,noAction);
  1006.         else
  1007.             build(e,co);
  1008.     }
  1009.  
  1010.     if (nr>0) {
  1011.         asMKAP(nr);
  1012.     }
  1013.     }
  1014. }
  1015.  
  1016. /* --------------------------------------------------------------------------
  1017.  * Code generator entry point:
  1018.  * ------------------------------------------------------------------------*/
  1019.  
  1020. Addr codeGen(n,arity,e)            /* Generate code for expression e,  */
  1021. Name n;                    /* treating return value of CAFs    */
  1022. Int  arity;                   /* differently to functs with args  */
  1023. Cell e; {
  1024.     extern Void pScDef Args((Text,Int,Cell));
  1025.     extern Bool dumpScs;
  1026.  
  1027.     definingName  = n;
  1028.     definingArity = arity;
  1029.     scDeps      = NIL;
  1030. #ifdef DEBUG_CODE
  1031. printf("------------------\n");
  1032. if (nonNull(n)) printf("name=%s\n",textToStr(name(n).text));
  1033. printf("Arity   = %d\n",arity);
  1034. printf("codeGen = "); printExp(stdout,e); putchar('\n');
  1035. #endif
  1036.     if (dumpScs)
  1037.     pScDef(name(n).text,arity,e);
  1038.     else {
  1039.     Int i;
  1040.     asSTART();
  1041.     for (i=1; i<=arity; i++)
  1042.         offsPosn[i] = ++srsp;
  1043.     make(e,arity,FAIL,functionReturn);
  1044.     asEND();
  1045.     }
  1046.     name(n).defn = scDeps;
  1047.     scDeps     = NIL;
  1048. #ifdef DEBUG_CODE
  1049. dissassemble(startInstr);
  1050. printf("------------------\n");
  1051. #endif
  1052.     return startInstr;
  1053. }
  1054.  
  1055. /* --------------------------------------------------------------------------
  1056.  * C code generator: produces (portable, I hope) C output to implement a
  1057.  * specified main program.
  1058.  * ------------------------------------------------------------------------*/
  1059.  
  1060. Void outputCode(fp,mn)            /* print complete C program to       */
  1061. FILE *fp;                /* implement program mn :: Dialogue*/
  1062. Name mn; {
  1063.     List   scs = identifyDeps(mn);    /* determine which supercombinator */
  1064.     Target t   = length(scs);        /* definitions are needed in prog. */
  1065.     Target i   = 0;
  1066.  
  1067.     fprintf(fp,"#include %s\n\nint argcheck=ARGCHECK;\n\n",GOFC_INCLUDE);
  1068.     outputCDecls(fp,scs);
  1069.     outputCDicts(fp);
  1070.  
  1071.     setGoal("Compiling to C",t);
  1072.     for (; nonNull(scs); scs=tl(scs)) {
  1073.     outputCSc(fp,hd(scs));
  1074.     soFar(i++);
  1075.     }
  1076.     done();
  1077. }
  1078.  
  1079. static int *dictUse   = 0;        /* records dictionaries required   */
  1080. static int num_cdicts  = 0;        /* dictionaries required       */
  1081. static int num_sdicts = 0;        /* all dictionaries known to system*/
  1082.  
  1083. static List local identifyDeps(mn)    /* list all dependents scs for mn  */
  1084. Name mn; {
  1085.     List needed     = singleton(mn);    /* Start with dependents of mn       */
  1086.     List scs        = NIL;
  1087.     List ns        = NIL;
  1088.     Int  i;
  1089.  
  1090.     num_sdicts = newDict(0);
  1091.     dictUse    = (int *)calloc(num_sdicts,sizeof(int));
  1092.     if (!dictUse) {
  1093.     ERROR(0) "Cannot allocate dictionary use table"
  1094.     EEND;
  1095.     }
  1096.     for (i=0; i<num_sdicts; i++)
  1097.     dictUse[i] = (-1);        /* (-1) => not required           */
  1098.  
  1099.     while (nonNull(needed)) {        /* Cycle through to find all       */
  1100.     Cell t = needed;        /* dependents ...           */
  1101.     Cell n = hd(t);
  1102.     needed = tl(needed);
  1103.     if (isName(n)) {        /* Dependent is a name           */
  1104.          if (!name(n).primDef && name(n).defn!=NEEDED) {
  1105.           tl(t)        = scs;
  1106.           scs         = t;
  1107.          map1Proc(checkPrimDep,n,name(n).defn);
  1108.         needed       = appendOnto(name(n).defn,needed);
  1109.         name(n).defn = NEEDED;
  1110.         }
  1111.     }
  1112.     else {                /* Dependent is a dictionary       */
  1113.         if (dictUse[dictOf(n)]<0)
  1114.         for (i=dictOf(n); (dictUse[i++]=0), i<num_sdicts; )
  1115.             if (isAp(dict(i))) {    /* member function       */
  1116.             if (isName(fun(dict(i))) &&
  1117.                 whatIs(arg(dict(i)))==DICTCELL)
  1118.                 needed = cons(fun(dict(i)),needed);
  1119.             else
  1120.                 if (fun(dict(i))!=nameUndefMem)
  1121.                 internal("bad dict ap");
  1122.             }
  1123.             else            /* DICTCELL           */
  1124.             if (dictOf(dict(i))==i)    /* past end of dictionary  */
  1125.                 break;
  1126.             else
  1127.                 needed = cons(dict(i),needed);
  1128.         }
  1129.     }
  1130.  
  1131.     ns = scs;                /* number supercombinators       */
  1132.     for (i=0; nonNull(ns); ns=tl(ns))
  1133.     name(hd(ns)).number = i++;
  1134.  
  1135.     num_cdicts = 0;            /* number dictionaries           */
  1136.     for (i=0; i<num_sdicts; i++)
  1137.     if (dictUse[i]!=(-1))
  1138.         dictUse[i] = num_cdicts++;
  1139.  
  1140.     return scs;
  1141. }
  1142.  
  1143. static Void local checkPrimDep(n,m)    /* Check that primitive dependent  */
  1144. Name n;                    /* m of n is supported by gofc       */
  1145. Cell m; {
  1146.     if (isName(m) && name(m).primDef == PRIM_NOGOFC) {
  1147.     ERROR(0)
  1148.      "Primitive function %s is not supported by the gofc runtime system\n",
  1149.          primitives[name(m).number].ref
  1150.     ETHEN
  1151.     ERRTEXT "(used in the definition of %s)", textToStr(name(n).text)
  1152.     EEND;
  1153.     }
  1154. }
  1155.  
  1156. static Void local outputCDecls(fp,scs)    /* print forward declarations for  */
  1157. FILE *fp;                /* supercombinators required       */
  1158. List scs; {
  1159.     int num_scs = length(scs);
  1160.  
  1161.     startTable("extern Super ", ";", ";\n");
  1162. #define declareSc(n) tableItem(fp,scNameOf(n))
  1163.     mapProc(declareSc,scs);
  1164. #undef  declareSc
  1165.     finishTable(fp);
  1166.  
  1167.     fprintf(fp,"\nint   num_scs = %d;\nCell  sc[%d];",num_scs,num_scs);
  1168.     fprintf(fp,"\nSuper *scNames[] = {\n");
  1169.     startTable("  ", ", ", "\n");
  1170. #define inArraySc(n) tableItem(fp,scNameOf(n))
  1171.     mapProc(inArraySc,scs);
  1172. #undef  inArraySc
  1173.     finishTable(fp);
  1174.     fprintf(fp,"};\n\n");
  1175. }
  1176.  
  1177. static Void local outputCDicts(fp)    /* print definitions for dictionary*/
  1178. FILE *fp; {                /* storage               */
  1179.     char buffer[100];
  1180.  
  1181.     fprintf(fp,"int  num_cdicts = %d;\n",num_cdicts);
  1182.  
  1183.     if (num_cdicts==0) {
  1184.     fprintf(fp,"Cell dict[]     = {0}; /* dummy entries */\n");
  1185.     fprintf(fp,"int  dictImps[] = {0};\n\n");
  1186.     }
  1187.     else {
  1188.     Int dn;
  1189.     fprintf(fp,"Cell dict[] = {\n");
  1190.     startTable("  ", ",", "\n");
  1191.         for (dn=0; dn<num_sdicts; dn++) {
  1192.         if (dictUse[dn]>=0) {
  1193.                 if (isAp(dict(dn))) {
  1194.             if (fst(dict(dn))==nameUndefMem)
  1195.             tableItem(fp,"0");
  1196.             else {
  1197.             sprintf(buffer,"mkDict(%d)",
  1198.                     dictUse[dictOf(arg(dict(dn)))]);
  1199.             tableItem(fp,buffer);
  1200.             }
  1201.         }
  1202.         else {
  1203.             sprintf(buffer,"mkDict(%d)",dictUse[dictOf(dict(dn))]);
  1204.             tableItem(fp,buffer);
  1205.         }
  1206.         }
  1207.     }
  1208.     finishTable(fp);
  1209.     fprintf(fp,"};\nint dictImps[] = {\n");
  1210.     startTable("  ", ",", "\n");
  1211.     for (dn=0; dn<num_sdicts; dn++)
  1212.         if (dictUse[dn]>=0)
  1213.         if (isAp(dict(dn))) {
  1214.             sprintf(buffer,"%d",name(fun(dict(dn))).number);
  1215.             tableItem(fp,buffer);
  1216.         }
  1217.         else
  1218.             tableItem(fp,"-1");
  1219.     finishTable(fp);
  1220.     fprintf(fp,"};\n\n");
  1221.     }
  1222. }
  1223.  
  1224. /* --------------------------------------------------------------------------
  1225.  * Supercombinator C code generator:
  1226.  *
  1227.  * The C code generator re-interprets the sequence of machine instructions
  1228.  * produced by the G-code code generator given above, using a simulated
  1229.  * stack, in much the same way as described in Simon Peyton Jones's book,
  1230.  * section 19.3.2.  To be quite honest, I don't think I really understood
  1231.  * that section of the book until I started to work on this piece of code!
  1232.  * ------------------------------------------------------------------------*/
  1233.  
  1234. static  int    rsp;            /* Runtime stack pointer       */
  1235. static  int    rspMax;            /* Maximum value of stack pointer  */
  1236. static  int    pushes;            /* number of actual pushes in code */
  1237.  
  1238. #define rPush  if (++rsp>=rspMax) rspMax=rsp
  1239.  
  1240. static Void local rspRecalc() {        /* Recalculate rsp after change to */
  1241.     Int i = sp;                /* simulated stack pointer sp       */
  1242.     for (rsp=(-1); i>=0; --i)
  1243.     if (isNull(stack(i)) || stack(i)==mkOffset(i))
  1244.         rsp++;
  1245.     if (rsp>rspMax)            /* should never happen!           */
  1246.     rspMax = rsp;
  1247. }
  1248.  
  1249. /* --------------------------------------------------------------------------
  1250.  * Output code for a single supercombinator:
  1251.  * ------------------------------------------------------------------------*/
  1252.  
  1253. #define ppushed(n)  (isNull(pushed(n)) ? POP : pushed(n))
  1254. #define tpushed(n)  (isNull(pushed(n)) ? TOP : pushed(n))
  1255.  
  1256. static Void local outputCSc(fp,n)    /* Print C code for supercombinator*/
  1257. FILE *fp;
  1258. Name n; {
  1259.     List   instrs = heapUse(cCode(name(n).arity,name(n).code));
  1260.     String s      = 0;
  1261.  
  1262.     if (name(n).arity<10)        /* Print header               */
  1263.     fprintf(fp,"comb%d(%s)",name(n).arity,scNameOf(n));
  1264.     else
  1265.     fprintf(fp,"comb(%s,%d)",scNameOf(n),name(n).arity);
  1266.  
  1267.     fprintf(fp,"  /* ");        /* include supercombinator name       */
  1268.     for (s=textToStr(name(n).text); *s; s++) {
  1269.     fputc(*s,fp);
  1270.     if (*s=='*' && *(s+1)=='/')    /* avoid premature comment ending  */
  1271.         fputc(' ',fp);
  1272.     }
  1273.     fprintf(fp," */\n");
  1274.  
  1275.     if (pushes>0 && rspMax>name(n).arity)
  1276.     fprintf(fp,"  needStack(%d);\n",rspMax-name(n).arity);
  1277.  
  1278.     for (; nonNull(instrs); instrs=tl(instrs)) {
  1279.     Cell instr = hd(instrs);
  1280.  
  1281.     if (whatIs(instr)==C_LABEL) {    /* Handle printing of labels       */
  1282.         instrs = tl(instrs);    /* move on to next instruction       */
  1283.         if (isNull(instrs))
  1284.         internal("no instr for label");
  1285.         outputLabel(fp,intOf(snd(instr)));
  1286.         fputc(':',fp);
  1287.         instr   = hd(instrs);
  1288.     }
  1289.     else
  1290.         fprintf(fp,"  ");
  1291.  
  1292.         outputCinst(fp,instr);
  1293.     fprintf(fp,";\n");
  1294.     }
  1295.  
  1296.     fprintf(fp,"End\n\n");
  1297. }
  1298.  
  1299. static List local cCode(arity,pc)    /* simulate execution of G-code to */
  1300. Int  arity;                /* calculate corresponding C code  */
  1301. Addr pc; {
  1302.     Cell instrs = NIL;            /* holds sequence of C instrs       */
  1303.     Int  i;
  1304.     Cell t;
  1305.  
  1306.     clearStack();            /* initialise simulated stack       */
  1307.     for (i=0; i<=arity; i++) {
  1308.     push(mkOffset(i));
  1309.     }
  1310.     rsp    = arity;            /* and set Real stack ptr to match */
  1311.     rspMax = rsp;
  1312.     pushes = 0;
  1313.  
  1314. #define outC0(c)    instrs = cons(c,instrs)
  1315. #define outC1(c,o)    instrs = cons(ap(c,o),instrs)
  1316. #define outC2(c,o,p)    instrs = cons(ap(c,pair(o,p)),instrs)
  1317. #define outC3(c,o,p,q)    instrs = cons(ap(c,triple(o,p,q)),instrs)
  1318.  
  1319.     for (;;)
  1320.     switch (instrAt(pc)) {
  1321.  
  1322.         case iEND     : return rev(instrs);         /* end of code       */
  1323.  
  1324.         case iLABEL     : outC1(C_LABEL,         /* program label  */
  1325.                  mkInt(labAt(pc+1)));
  1326.                pc+=2;
  1327.                continue;
  1328.  
  1329.         case iLOAD     : push(mkOffset(intAt(pc+1)));     /* load from stack*/
  1330.                pc+=2;
  1331.                continue;
  1332.  
  1333.         case iCELL     : push(cellAt(pc+1));         /* load const Cell*/
  1334.                pc+=2;
  1335.                continue;
  1336.  
  1337.         case iCHAR     : push(mkChar(intAt(pc+1)));     /* load char const*/
  1338.                pc+=2;
  1339.                continue;
  1340.  
  1341.         /* the treatment of integers used here relies on the assumption*/
  1342.         /* that any number represented by a small int in the compiler  */
  1343.         /* can also be represented by a small int in the runtime system*/
  1344.  
  1345.         case iINT     : t = mkInt(intAt(pc+1));     /* load int const */
  1346.                if (!isSmall(t)) {         /* assume BIG int */
  1347.                    push(NIL);
  1348.                    rPush;
  1349.                    pushes++;
  1350.                    outC0(t);
  1351.                }
  1352.                else {                 /* assume SMALL   */
  1353.                    push(t);
  1354.                }
  1355.                pc+=2;
  1356.                continue;
  1357.  
  1358.         case iFLOAT  : push(NIL);             /* load float cnst*/
  1359.                rPush;
  1360.                pushes++;
  1361. #if BREAK_FLOATS
  1362.                outC0(mkFloat(floatFromParts
  1363.                         (cellAt(pc+1),cellAt(pc+2))));
  1364.                pc+=3;
  1365. #else
  1366.                outC0(mkFloat(floatAt(pc+1)));
  1367.                pc+=2;
  1368. #endif
  1369.                continue;
  1370.  
  1371.         case iFLUSH  : if (nonNull(top())) {     /* force top of   */
  1372.                    outC1(C_FLUSH,top());     /* simulated stack*/
  1373.                    top() = NIL;         /* onto real stack*/
  1374.                    rPush;
  1375.                    pushes++;
  1376.                }
  1377.                pc++;
  1378.                continue;
  1379.  
  1380.         case iSTRING : push(NIL);             /* load str const */
  1381.                rPush;
  1382.                pushes++;
  1383.                outC0(mkStr(textAt(pc+1)));
  1384.                pc+=2;
  1385.                continue;
  1386.  
  1387.         case iMKAP   : for (i=intAt(pc+1); i>0; --i){/* make AP nodes  */
  1388.                    if (isNull(pushed(0)))
  1389.                    if (isNull(pushed(1))) {
  1390.                        outC0(C_MKAP);
  1391.                        rsp--;
  1392.                    }
  1393.                    else
  1394.                        outC1(C_TOPARG,pushed(1));
  1395.                    else
  1396.                    if (isNull(pushed(1)))
  1397.                        outC1(C_TOPFUN,pushed(0));
  1398.                    else {
  1399.                        rPush;
  1400.                        pushes++;
  1401.                        outC2(C_PUSHPAIR,pushed(0),pushed(1));
  1402.                    }
  1403.                    drop();
  1404.                    top() = NIL;
  1405.                }
  1406.                pc+=2;
  1407.                continue;
  1408.  
  1409.         case iUPDATE : t = stack(intAt(pc+1));     /* update cell ...*/
  1410.                if (!isOffset(t))
  1411.                    internal("iUPDATE");
  1412.                    
  1413.                if(offsetOf(t)!=0)
  1414.                  stack(intAt(pc+1)) = NIL;
  1415.                if (isNull(pushed(0)))     /* update cell ...*/
  1416.                    rsp--;
  1417.  
  1418.                outC2(C_UPDATE,t,ppushed(0));
  1419.  
  1420.                drop();
  1421.                pc+=2;
  1422.                continue;
  1423.  
  1424.         case iUPDAP  : t = stack(intAt(pc+1));     /* update AP node */
  1425.                if (!isOffset(t))
  1426.                    internal("iUPDAP");
  1427.                if(offsetOf(t)!=0)
  1428.                  stack(intAt(pc+1)) = NIL;
  1429.  
  1430.                if (isNull(pushed(0)))
  1431.                    if (isNull(pushed(1))) {
  1432.                    outC1(C_UPDAP2,t);
  1433.                    rsp-=2;
  1434.                    }
  1435.                    else {
  1436.                    outC3(C_UPDAP,t,POP,pushed(1));
  1437.                    rsp--;
  1438.                    }
  1439.                else
  1440.                    if (isNull(pushed(1))) {
  1441.                    outC3(C_UPDAP,t,pushed(0),POP);
  1442.                                    rsp--;
  1443.                    }
  1444.                    else
  1445.                    outC3(C_UPDAP,t,pushed(0),pushed(1));
  1446.  
  1447.                drop();
  1448.                drop();
  1449.                pc+=2;
  1450.                continue;
  1451.  
  1452.         case iALLOC  : for (i=intAt(pc+1); i>0; --i){/* alloc loc vars */
  1453.                    rPush;
  1454.                    pushes++;
  1455.                    outC0(C_ALLOC);
  1456.                    push(mkOffset(rsp));
  1457.                }
  1458.                pc+=2;
  1459.                continue;
  1460.  
  1461.         case iSLIDE  : i = intAt(pc+1);         /* remove loc vars*/
  1462.                if (nonNull(top()))
  1463.                    i--;
  1464.                outC2(C_SLIDE,mkInt(i),tpushed(0));
  1465.                rsp -= i;
  1466.                sp  -= intAt(pc+1);
  1467.                            pc  += 2;
  1468.                continue;
  1469.  
  1470.         case iDICT     : if (isNull(top()))         /* dict lookup    */
  1471.                    internal("iDICT");
  1472.  
  1473.                if (whatIs(top())==DICTCELL)
  1474.                    top() = mkDict(dictOf(top())+intAt(pc+1));
  1475.                else
  1476.                    top() = ap(mkSelect(intAt(pc+1)),top());
  1477.  
  1478.                            pc+=2;                        /* dict lookup    */
  1479.                            continue;
  1480.  
  1481.         case iROOT     : t = mkOffset(0);         /* partial root   */
  1482.                for (i=intAt(pc+1); i>0; --i)
  1483.                    t = ap(ROOTFST,t);
  1484.                push(t);
  1485.                pc+=2;
  1486.                continue;
  1487.  
  1488.         case iRETURN : outC0(C_RETURN);         /* terminate       */
  1489.                pc++;
  1490.                continue;
  1491.  
  1492.         case iGOTO     : outC1(C_GOTO,         /* goto label       */
  1493.                  mkInt(labAt(pc+1)));
  1494.                pc+=2;
  1495.                continue;
  1496.  
  1497.         case iSETSTK : sp = intAt(pc+1);         /* set stack ptr  */
  1498.                rspRecalc();
  1499.                outC1(C_SETSTK,mkInt(rsp));
  1500.                pc += 2;
  1501.                continue;
  1502.  
  1503.         case iSTKIS  : sp = intAt(pc+1);         /* set stack ptr  */
  1504.                rspRecalc();             /* but no C code  */
  1505.                pc += 2;
  1506.                continue;
  1507.  
  1508.         case iINTEQ     :                  /* test integer ==*/
  1509.                outC2(C_INTEQ,mkInt(intAt(pc+1)),
  1510.                      mkInt(labAt(pc+2)));
  1511.                pc+=3;
  1512.                continue;
  1513.  
  1514.         case iINTGE     : push(NIL);             /* test integer >=*/
  1515.                rPush;
  1516.                pushes++;
  1517.                outC3(C_INTGE,mkInt(0),
  1518.                      mkInt(intAt(pc+1)),
  1519.                      mkInt(labAt(pc+2)));
  1520.                            pc+=3;
  1521.                continue;
  1522.  
  1523.         case iINTDV     : push(NIL);             /* test for mult  */
  1524.                rPush;
  1525.                pushes++;
  1526.                outC3(C_INTDV,mkInt(0),
  1527.                      mkInt(intAt(pc+1)),
  1528.                      mkInt(labAt(pc+2)));
  1529.                pc+=3;
  1530.                continue;
  1531.  
  1532.         case iTEST     : t = cellAt(pc+1);         /* test for cell  */
  1533.                switch (whatIs(t)) {
  1534.                    case UNIT     : i = 0;
  1535.                            break;
  1536.  
  1537.                    case TUPLE    : i = tupleOf(t);
  1538.                            break;
  1539.  
  1540.                    case NAME     : i = name(t).arity;
  1541.                            outC2(C_TEST,t,
  1542.                          mkInt(labAt(pc+2)));
  1543.                            break;
  1544.  
  1545.                    case CHARCELL : i = 0;
  1546.                            outC2(C_TEST,t,
  1547.                          mkInt(labAt(pc+2)));
  1548.                            break;
  1549.  
  1550.                    default         : internal("iTEST");
  1551.                }
  1552.  
  1553.                while (i-- > 0) {
  1554.                    rPush;
  1555.                    push(mkOffset(rsp));
  1556.                }
  1557.                pc+=3;
  1558.                continue;
  1559.  
  1560.         case iEVAL     : if (isNull(pushed(0)))     /* evaluate top() */
  1561.                    rsp--;
  1562.                outC1(C_EVAL,ppushed(0));
  1563.                drop();
  1564.                pc++;
  1565.                continue;
  1566.  
  1567.         default     : internal("illegal instruction");
  1568.                break;
  1569.     }
  1570.  
  1571. #undef outC0
  1572. #undef outC1
  1573. #undef outC2
  1574. #undef outC3
  1575. }
  1576.  
  1577. /* --------------------------------------------------------------------------
  1578.  * Insert heap use annotations:
  1579.  * ------------------------------------------------------------------------*/
  1580.  
  1581. static Int heapNeeded;            /* used to return # heap cells reqd*/
  1582.  
  1583. static List local heapUse(instrs)    /* add annotations for heap use       */
  1584. List instrs; {
  1585.     instrs = heapAnalyse(instrs);
  1586.     if (heapNeeded>0)
  1587.     instrs = cons(ap(C_HEAP,mkInt(heapNeeded)),instrs);
  1588.     return instrs;
  1589. }
  1590.  
  1591. static List local heapAnalyse(instrs)    /* analyse heap use in instruction */
  1592. List instrs; {
  1593.     Int  heap = 0;            /* number of heap cells needed     */
  1594.     List next;
  1595.  
  1596.     for (next=instrs; nonNull(next); next=tl(next))
  1597.     switch (whatIs(hd(next))) {
  1598.         case FLOATCELL  : heap+=4;        /*conservative overestimate*/
  1599.                   continue;        /*without BREAK_FLOATS this*/
  1600.                         /*will always use just one */
  1601.                         /*cell, with it may use 1-4*/
  1602.  
  1603.         case INTCELL    :            /*conservative overestimate*/
  1604.                         /*again. Small ints may not*/
  1605.                         /*require any heap storage */
  1606.         case STRCELL    :
  1607.         case C_MKAP        :
  1608.         case C_TOPFUN   :
  1609.         case C_TOPARG   :
  1610.         case C_PUSHPAIR :
  1611.         case C_ALLOC    : heap++;
  1612.         case C_UPDAP    :
  1613.         case C_UPDAP2   :
  1614.         case C_UPDATE   :
  1615.         case C_SLIDE    :
  1616.         case C_SETSTK   :
  1617.         case C_FLUSH    : continue;
  1618.  
  1619.         case C_INTGE    :
  1620.         case C_INTDV    : tl(next)          = heapAnalyse(tl(next));
  1621.                   fst3(snd(hd(next))) = mkInt(1+heapNeeded);
  1622.                   heapNeeded      = heap;
  1623.                   return instrs;
  1624.  
  1625.         case C_TEST        :
  1626.         case C_INTEQ    :
  1627.         case C_LABEL    :
  1628.         case C_GOTO     :
  1629.         case C_RETURN   :
  1630.         case C_EVAL        : tl(next)   = heapUse(tl(next));
  1631.                   heapNeeded = heap;
  1632.                               return instrs;
  1633.  
  1634.         default        : internal("heapAnalyse");
  1635.     }
  1636.  
  1637.     heapNeeded = heap;
  1638.     return instrs;
  1639. }
  1640.  
  1641. /* --------------------------------------------------------------------------
  1642.  * Output individual C code instructions:
  1643.  * ------------------------------------------------------------------------*/
  1644.  
  1645. static Void local outputCinst(fp,instr)    /* Output single C instruction       */
  1646. FILE *fp;
  1647. Cell instr; {
  1648.     switch (whatIs(instr)) {
  1649.     case INTCELL    : fprintf(fp,"pushInt(%d)",intOf(instr));
  1650.               break;
  1651.  
  1652.     case FLOATCELL  : fprintf(fp,"pushFloat(%s)",
  1653.                     floatToString(floatOf(instr)));
  1654.               break;
  1655.  
  1656.     case STRCELL    : fprintf(fp,"pushStr(");
  1657.               outputCStr(fp,textToStr(textOf(instr)));
  1658.               fputc(')',fp);
  1659.               break;
  1660.  
  1661.     case C_MKAP    : fprintf(fp,"mkap()");
  1662.               break;
  1663.  
  1664.     case C_TOPARG   : fprintf(fp,"toparg(");
  1665.               expr(fp,snd(instr));
  1666.               fputc(')',fp);
  1667.               break;
  1668.  
  1669.     case C_TOPFUN   : fprintf(fp,"topfun(");
  1670.               expr(fp,snd(instr));
  1671.               fputc(')',fp);
  1672.               break;
  1673.  
  1674.     case C_PUSHPAIR : fprintf(fp,"pushpair(");
  1675.               expr(fp,fst(snd(instr)));
  1676.               fputc(',',fp);
  1677.               expr(fp,snd(snd(instr)));
  1678.               fputc(')',fp);
  1679.               break;
  1680.  
  1681.     case C_UPDATE   : fprintf(fp,"update(%d,",offsetOf(fst(snd(instr))));
  1682.               expr(fp,snd(snd(instr)));
  1683.               fputc(')',fp);
  1684.               break;
  1685.  
  1686.     case C_UPDAP    : fprintf(fp,"updap(%d,",offsetOf(fst3(snd(instr))));
  1687.               expr(fp,snd3(snd(instr)));
  1688.               fputc(',',fp);
  1689.               expr(fp,thd3(snd(instr)));
  1690.               fputc(')',fp);
  1691.               break;
  1692.  
  1693.     case C_UPDAP2    : fprintf(fp,"updap2(%d)",offsetOf(snd(instr)));
  1694.               break;
  1695.  
  1696.     case C_ALLOC    : fprintf(fp,"alloc()");
  1697.               break;
  1698.  
  1699.     case C_SLIDE    : fprintf(fp,"slide(%d,",intOf(fst(snd(instr))));
  1700.               expr(fp,snd(snd(instr)));
  1701.               fputc(')',fp);
  1702.               break;
  1703.  
  1704.     case C_RETURN   : fprintf(fp,"ret()");
  1705.               break;
  1706.  
  1707.     case C_GOTO    : outputJump(fp,intOf(snd(instr)));
  1708.               break;
  1709.  
  1710.     case C_FLUSH    : fprintf(fp,"onto(");
  1711.               expr(fp,snd(instr));
  1712.               fputc(')',fp);
  1713.               break;
  1714.  
  1715.     case C_SETSTK   : fprintf(fp,"setstk(%d)",intOf(snd(instr)));
  1716.               break;
  1717.  
  1718.     case C_HEAP    : fprintf(fp,"heap(%d)",intOf(snd(instr)));
  1719.               break;
  1720.  
  1721.     case C_INTEQ    : fprintf(fp,"inteq(%d) ",intOf(fst(snd(instr))));
  1722.               outputJump(fp,intOf(snd(snd(instr))));
  1723.               break;
  1724.  
  1725.     case C_INTGE    : fprintf(fp,"intge(%d,%d) ",intOf(fst3(snd(instr))),
  1726.                              intOf(snd3(snd(instr))));
  1727.               outputJump(fp,intOf(thd3(snd(instr))));
  1728.               break;
  1729.  
  1730.     case C_INTDV    : fprintf(fp,"intdv(%d,%d) ",intOf(fst3(snd(instr))),
  1731.                              intOf(snd3(snd(instr))));
  1732.               outputJump(fp,intOf(thd3(snd(instr))));
  1733.               break;
  1734.  
  1735.     case C_TEST    : fprintf(fp,"test(");
  1736.               expr(fp,fst(snd(instr)));
  1737.               fprintf(fp,") ");
  1738.               outputJump(fp,intOf(snd(snd(instr))));
  1739.               break;
  1740.  
  1741.     case C_EVAL    : fprintf(fp,"eval(");
  1742.               expr(fp,snd(instr));
  1743.               fputc(')',fp);
  1744.               break;
  1745.  
  1746.     default        : internal("bad C code");
  1747.     }
  1748. }
  1749.  
  1750. /* --------------------------------------------------------------------------
  1751.  * Output small parts of an expression:
  1752.  * ------------------------------------------------------------------------*/
  1753.  
  1754. static Void local expr(fp,n)        /* print C expression for value       */
  1755. FILE *fp;
  1756. Cell n; {
  1757.  
  1758.     switch (whatIs(n)) {
  1759.  
  1760.     case TOP      : fprintf(fp,"top()");
  1761.             break;
  1762.  
  1763.     case POP      : fprintf(fp,"pop()");
  1764.             break;
  1765.  
  1766.     case OFFSET   : fprintf(fp,"offset(%d)",offsetOf(n));
  1767.             break;
  1768.  
  1769.     case CHARCELL : fprintf(fp,"mkChar(%d)",charOf(n));
  1770.             break;
  1771.  
  1772.     case INTCELL  : fprintf(fp,"mkSmall(%d)",intOf(n));
  1773.             break;
  1774.  
  1775.     case AP          : if (fst(n)==ROOTFST) {
  1776.                 fprintf(fp,"rootFst(");
  1777.                 expr(fp,arg(n));
  1778.                 fputc(')',fp);
  1779.             }
  1780.             else if (isSelect(fst(n))) {
  1781.                 fprintf(fp,"dsel(%d,",selectOf(fst(n)));
  1782.                 expr(fp,arg(n));
  1783.                 fputc(')',fp);
  1784.             }
  1785.             else
  1786.                 internal("exprAP");
  1787.             break;
  1788.  
  1789.     case DICTCELL : fprintf(fp,"dict[%d]",dictUse[dictOf(n)]);
  1790.             break;
  1791.  
  1792.     case UNIT     : fprintf(fp,"mkCfun(0)");
  1793.             break;
  1794.  
  1795.     case TUPLE    : fprintf(fp,"mkCfun(%d)",tupleOf(n));
  1796.             break;
  1797.  
  1798.     case NAME     : if (name(n).defn==CFUN)
  1799.                 fprintf(fp,"mkCfun(%d)",name(n).number);
  1800.             else if (name(n).primDef)
  1801.                 fprintf(fp,"%s",primitives[name(n).number].ref);
  1802.             else
  1803.                 fprintf(fp,"sc[%d]",name(n).number);
  1804.             break;
  1805.  
  1806.     default          : internal("expr");
  1807.     }
  1808. }
  1809.  
  1810. static Void local outputLabel(fp,lab)    /* print C program label       */
  1811. FILE *fp;
  1812. Int  lab; {
  1813.     if (lab<=26)
  1814.     fputc('a'+lab-1, fp);
  1815.     else
  1816.     fprintf(fp,"a%d",lab-26);
  1817. }
  1818.  
  1819. static Void local outputJump(fp,lab)    /* print jump to label, taking       */
  1820. FILE *fp;                /* special account of FAIL label   */
  1821. Int  lab; {
  1822.     if (lab==FAIL)
  1823.     fprintf(fp,"fail()");
  1824.     else {
  1825.     fprintf(fp,"goto ");
  1826.     outputLabel(fp,lab);
  1827.     }
  1828. }
  1829.  
  1830. static Void local outputCStr(fp,s)    /* print out string, taking care   */
  1831. FILE   *fp;                /* to avoid problems with C escape */
  1832. String s; {                /* sequences               */
  1833.     fputc('"',fp);
  1834.     for (; *s; s++) {
  1835.         if (*s=='\\' || *s=='"')
  1836.         fprintf(fp,"\\%c",*s);
  1837.     else if (isprint(*s))
  1838.         fputc(*s,fp);
  1839.     else if (*s=='\n')
  1840.         fprintf(fp,"\\n");
  1841.     else
  1842.         fprintf(fp,"\\%03o",(*s<0 ? *s+NUM_CHARS : *s));
  1843.     }
  1844.     fputc('"',fp);
  1845. }
  1846.  
  1847. static Bool local validCstring(s)    /* check whether string s is valid */
  1848. String s; {                /* C identifier               */
  1849.     for (; *s && isascii(*s) && isalnum(*s); s++)
  1850.     ;
  1851.     return *s=='\0';
  1852. }
  1853.  
  1854. static String local scNameOf(n)        /* get name of C implementation of */
  1855. Name n; {                /* a particular supercombinator       */
  1856.     String s = textToStr(name(n).text);
  1857.     static char buffer[100];
  1858.  
  1859.     if (validCstring(s) && strlen(s)<96)
  1860.     sprintf(buffer,"sc_%s",s);
  1861.     else
  1862.     sprintf(buffer,"sc_%d",name(n).number);
  1863.  
  1864.     return buffer;
  1865. }
  1866.  
  1867. /* --------------------------------------------------------------------------
  1868.  * Pretty printing of tables:
  1869.  * ------------------------------------------------------------------------*/
  1870.  
  1871. #define TABLEWIDTH 72
  1872. static int    tableCol;
  1873. static int    tableItems;
  1874. static String tableStart;
  1875. static String tableEndLine;
  1876. static String tableEndTab;
  1877.  
  1878. static Void local startTable(start,endLine,endTab)
  1879. String start;
  1880. String endLine;
  1881. String endTab; {
  1882.     tableStart   = start;
  1883.     tableEndLine = endLine;
  1884.     tableEndTab  = endTab;
  1885.     tableCol     = 0;
  1886.     tableItems   = 0;
  1887. }
  1888.  
  1889. static Void local finishTable(fp)
  1890. FILE *fp; {
  1891.     if (tableCol>0)
  1892.     fprintf(fp,tableEndTab);
  1893. }
  1894.  
  1895. static Void local tableItem(fp,s)
  1896. FILE   *fp;
  1897. String s; {
  1898.     int n = strlen(s);
  1899.  
  1900.     if (tableItems++ == 0) {
  1901.     fprintf(fp,tableStart);
  1902.     tableCol = strlen(tableStart);
  1903.     }
  1904.     else {
  1905.     if (tableCol+n+2>TABLEWIDTH) {
  1906.         fprintf(fp,"%s\n%s",tableEndLine,tableStart);
  1907.         tableCol = strlen(tableStart);
  1908.     }
  1909.     else {
  1910.         fprintf(fp,", ");
  1911.         tableCol+=2;
  1912.     }
  1913.     }
  1914.     fprintf(fp,"%s",s);
  1915.     tableCol += n;
  1916. }
  1917.  
  1918. /* --------------------------------------------------------------------------
  1919.  * Machine control:
  1920.  * ------------------------------------------------------------------------*/
  1921.  
  1922. Void machine(what)
  1923. Int what; {
  1924.     switch (what) {
  1925.     case RESET   : scDeps  = NIL;
  1926.                break;
  1927.  
  1928.     case MARK    : mark(scDeps);
  1929.                mark(shouldntFail);
  1930.                mark(functionReturn);
  1931.                mark(noAction);
  1932.                break;
  1933.  
  1934.     case INSTALL : machine(RESET);
  1935.                memory = (Memory)farCalloc(num_addrs,sizeof(MemCell));
  1936.                if (memory==0)
  1937.                fatal("Cannot allocate program memory");
  1938.  
  1939.                shouldntFail   = pair(mkInt(0),ERRCONT);
  1940.                functionReturn = pair(mkInt(0),UPDRETC);
  1941.                noAction          = pair(mkInt(0),RUNONC);
  1942.                break;
  1943.     }
  1944. }
  1945.  
  1946. /* ------------------------------------------------------------------------*/
  1947.